home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / MacPerl ƒ / Perl Source ƒ / Perl / perl.c < prev    next >
C/C++ Source or Header  |  1994-01-01  |  43KB  |  1,714 lines
  1. char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.8 $$Date: 1993/02/05 19:39:30 $\nPatch level: ###\n";
  2. /*
  3.  *    Copyright (c) 1991, Larry Wall
  4.  *
  5.  *    You may distribute under the terms of the Perl Artistic License, 
  6.  *    as specified in the README file.
  7.  *
  8.  * $Log:    perl.c,v $
  9.  * Revision 4.0.1.7  1992/06/08  14:50:39  lwall
  10.  * patch20: PERLLIB now supports multiple directories
  11.  * patch20: running taintperl explicitly now does checks even if $< == $>
  12.  * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
  13.  * patch20: perl -P now uses location of sed determined by Configure
  14.  * patch20: form feed for formats is now specifiable via $^L
  15.  * patch20: paragraph mode now skips extra newlines automatically
  16.  * patch20: eval "1 #comment" didn't work
  17.  * patch20: couldn't require . files
  18.  * patch20: semantic compilation errors didn't abort execution
  19.  * 
  20.  * Revision 4.0.1.6  91/11/11  16:38:45  lwall
  21.  * patch19: default arg for shift was wrong after first subroutine definition
  22.  * patch19: op/regexp.t failed from missing arg to bcmp()
  23.  * 
  24.  * Revision 4.0.1.5  91/11/05  18:03:32  lwall
  25.  * patch11: random cleanup
  26.  * patch11: $0 was being truncated at times
  27.  * patch11: cppstdin now installed outside of source directory
  28.  * patch11: -P didn't allow use of #elif or #undef
  29.  * patch11: prepared for ctype implementations that don't define isascii()
  30.  * patch11: added eval {}
  31.  * patch11: eval confused by string containing null
  32.  * 
  33.  * Revision 4.0.1.4  91/06/10  01:23:07  lwall
  34.  * patch10: perl -v printed incorrect copyright notice
  35.  * 
  36.  * Revision 4.0.1.3  91/06/07  11:40:18  lwall
  37.  * patch4: changed old $^P to $^X
  38.  * 
  39.  * Revision 4.0.1.2  91/06/07  11:26:16  lwall
  40.  * patch4: new copyright notice
  41.  * patch4: added $^P variable to control calling of perldb routines
  42.  * patch4: added $^F variable to specify maximum system fd, default 2
  43.  * patch4: debugger lost track of lines in eval
  44.  * 
  45.  * Revision 4.0.1.1  91/04/11  17:49:05  lwall
  46.  * patch1: fixed undefined environ problem
  47.  * 
  48.  * Revision 4.0  91/03/20  01:37:44  lwall
  49.  * 4.0 baseline.
  50.  * 
  51.  */
  52.  
  53. /*SUPPRESS 560*/
  54.  
  55. #ifdef macintosh
  56.  
  57. char * getenv();
  58. char **init_env(char **);
  59.  
  60. #ifndef MAC_STANDALONE
  61. #include <Resources.h>
  62.  
  63. short    gAppFile;
  64. short    gPrefsFile;
  65. void *     gSacrificialGoat = (void *) -1;
  66.  
  67. #ifdef PERFORMANCE
  68. #include <Perf.h>
  69.  
  70. TP2PerfGlobals    gPerfGlobals;
  71.  
  72. void FinalizePerf()
  73. {
  74.     PerfDump(gPerfGlobals, "\pPerfPerl.Out", true, 80);
  75.     TermPerf(gPerfGlobals);
  76. }
  77.  
  78. #endif
  79. #else
  80. #define RESOLVE_MAC_CONFLICTS
  81. #include <Dialogs.h>
  82. #endif
  83.  
  84. #else
  85. char * getenv();
  86. #endif
  87.  
  88. #include "EXTERN.h"
  89. #include "perl.h"
  90. #include "perly.h"
  91. #include "patchlevel.h"
  92.  
  93. #ifdef IAMSUID
  94. #ifndef DOSUID
  95. #define DOSUID
  96. #endif
  97. #endif
  98.  
  99. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  100. #ifdef DOSUID
  101. #undef DOSUID
  102. #endif
  103. #endif
  104.  
  105. static char* moreswitches();
  106. static void incpush();
  107. static char* cddir;
  108. static bool minus_c;
  109. static char patchlevel[6];
  110. static char *nrs = "\n";
  111. static int nrschar = '\n';      /* final char of rs, or 0777 if none */
  112. static int nrslen = 1;
  113.  
  114. main(argc,argv,env)
  115. register int argc;
  116. register char **argv;
  117. register char **env;
  118. {
  119.     register STR *str;
  120.     register char *s;
  121.     char *scriptname;
  122.     bool dosearch = FALSE;
  123. #ifdef DOSUID
  124.     char *validarg = "";
  125. #endif
  126.  
  127. #ifdef macintosh
  128. #ifndef MAC_STANDALONE
  129.     FSSpec    pref;
  130.     
  131.     InitToolbox();
  132. #ifdef PERFORMANCE
  133.     InitPerf(&gPerfGlobals, 10, 8, true, true, "\pCODE", 0, "\p", true, 0, 0x7fffff, 32);
  134.     PerfControl(gPerfGlobals, true);
  135.     atexit(FinalizePerf);
  136. #endif
  137.     
  138.     gAppFile     = CurResFile();
  139.     
  140.     if (Path2FSSpec(getenv("PrefsFolder"), &pref))
  141.         gPrefsFile = 0;
  142.     else if (FSpDown(&pref, "\pPerl Preferences"))
  143.         gPrefsFile = 0;
  144.     else {
  145.         gPrefsFile = HOpenResFile(pref.vRefNum, pref.parID, pref.name, fsRdPerm);
  146.     
  147.     if (gPrefsFile == -1)
  148.         gPrefsFile = 0;
  149.     }
  150. #endif
  151.     InitCursorCtl(NULL);
  152.  
  153.     env = init_env(env);
  154. #endif
  155.  
  156. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  157. #ifdef IAMSUID
  158. #undef IAMSUID
  159.     fatal("suidperl is no longer needed since the kernel can now execute\n\
  160. setuid perl scripts securely.\n");
  161. #endif
  162. #endif
  163.  
  164.     origargv = argv;
  165.     origargc = argc;
  166.     origenviron = environ;
  167.     uid = (int)getuid();
  168.     euid = (int)geteuid();
  169.     gid = (int)getgid();
  170.     egid = (int)getegid();
  171.     minus_c = 0;
  172.     sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
  173. #ifdef MSDOS
  174.     /*
  175.      * There is no way we can refer to them from Perl so close them to save
  176.      * space.  The other alternative would be to provide STDAUX and STDPRN
  177.      * filehandles.
  178.      */
  179.     (void)fclose(stdaux);
  180.     (void)fclose(stdprn);
  181. #endif
  182.     if (do_undump) {
  183.     origfilename = savestr(argv[0]);
  184.     do_undump = 0;
  185.     loop_ptr = -1;        /* start label stack again */
  186.     goto just_doit;
  187.     }
  188. #ifdef TAINT
  189. #ifndef DOSUID
  190.     if (uid == euid && gid == egid)
  191.     taintanyway = TRUE;        /* running taintperl explicitly */
  192. #endif
  193. #endif
  194.     (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
  195.     linestr = Str_new(65,80);
  196.     str_nset(linestr,"",0);
  197.     str = str_make("",0);        /* first used for -I flags */
  198.     curstash = defstash = hnew(0);
  199.     curstname = str_make("main",4);
  200.     stab_xhash(stabent("_main",TRUE)) = defstash;
  201.     defstash->tbl_name = "main";
  202.     incstab = hadd(aadd(stabent("INC",TRUE)));
  203.     incstab->str_pok |= SP_MULTI;
  204.     for (argc--,argv++; argc > 0; argc--,argv++) {
  205.     if (argv[0][0] != '-' || !argv[0][1])
  206.         break;
  207. #ifdef DOSUID
  208.     if (*validarg)
  209.     validarg = " PHOOEY ";
  210.     else
  211.     validarg = argv[0];
  212. #endif
  213.     s = argv[0]+1;
  214.       reswitch:
  215.     switch (*s) {
  216.     case '0':
  217.     case 'a':
  218.     case 'c':
  219.     case 'd':
  220.     case 'D':
  221.     case 'i':
  222.     case 'l':
  223.     case 'n':
  224.     case 'p':
  225.     case 'u':
  226.     case 'U':
  227.     case 'v':
  228.     case 'w':
  229.         if (s = moreswitches(s))
  230.         goto reswitch;
  231.         break;
  232.  
  233.     case 'e':
  234. #ifdef TAINT
  235.         if (euid != uid || egid != gid)
  236.         fatal("No -e allowed in setuid scripts");
  237. #endif
  238.         if (!e_fp) {
  239.             e_tmpname = savestr(TMPPATH);
  240.         (void)mktemp(e_tmpname);
  241.         if (!*e_tmpname)
  242.             fatal("Can't mktemp()");
  243.         e_fp = fopen(e_tmpname,"w");
  244.         if (!e_fp)
  245.             fatal("Cannot open temporary file");
  246.         }
  247.         if (argv[1]) {
  248.         fputs(argv[1],e_fp);
  249.         argc--,argv++;
  250.         }
  251.         (void)putc('\n', e_fp);
  252.         break;
  253.     case 'I':
  254. #ifdef TAINT
  255.         if (euid != uid || egid != gid)
  256.         fatal("No -I allowed in setuid scripts");
  257. #endif
  258.         str_cat(str,"-");
  259.         str_cat(str,s);
  260.         str_cat(str," ");
  261.         if (*++s) {
  262.         (void)apush(stab_array(incstab),str_make(s,0));
  263.         }
  264.         else if (argv[1]) {
  265.         (void)apush(stab_array(incstab),str_make(argv[1],0));
  266.         str_cat(str,argv[1]);
  267.         argc--,argv++;
  268.         str_cat(str," ");
  269.         }
  270.         break;
  271.     case 'P':
  272. #ifdef TAINT
  273.         if (euid != uid || egid != gid)
  274.         fatal("No -P allowed in setuid scripts");
  275. #endif
  276.         preprocess = TRUE;
  277.         s++;
  278.         goto reswitch;
  279.     case 's':
  280. #ifdef TAINT
  281.         if (euid != uid || egid != gid)
  282.         fatal("No -s allowed in setuid scripts");
  283. #endif
  284.         doswitches = TRUE;
  285.         s++;
  286.         goto reswitch;
  287.     case 'S':
  288. #ifdef TAINT
  289.         if (euid != uid || egid != gid)
  290.         fatal("No -S allowed in setuid scripts");
  291. #endif
  292.         dosearch = TRUE;
  293.         s++;
  294.         goto reswitch;
  295.     case 'x':
  296.         doextract = TRUE;
  297.         s++;
  298.         if (*s)
  299.         cddir = savestr(s);
  300.         break;
  301.     case '-':
  302.         argc--,argv++;
  303.         goto switch_end;
  304.     case 0:
  305.         break;
  306.     default:
  307.         fatal("Unrecognized switch: -%s",s);
  308.     }
  309.     }
  310.   switch_end:
  311.     scriptname = argv[0];
  312.     if (e_fp) {
  313.     if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
  314.         fatal("Can't write to temp file for -e: %s", strerror(errno));
  315.     argc++,argv--;
  316.     scriptname = e_tmpname;
  317.     }
  318.  
  319. #ifdef DOSISH
  320. #define PERLLIB_SEP ';'
  321. #else
  322. #ifdef macintosh
  323. #define PERLLIB_SEP ','
  324. #else
  325. #define PERLLIB_SEP ':'
  326. #endif
  327. #endif
  328. #ifndef TAINT        /* Can't allow arbitrary PERLLIB in setuid script */
  329. #ifdef MACPERL_STANDALONE
  330.     (void)apush(stab_array(incstab),str_make("Dev:Pseudo:",11));
  331. #endif
  332.     incpush(getenv("PERLLIB"));
  333. #endif /* TAINT */
  334.  
  335. #ifdef macintosh
  336. #ifdef PRIVLIB
  337.     incpush(PRIVLIB);
  338. #endif
  339.     (void)apush(stab_array(incstab),str_make(":",1));
  340. #else
  341. #ifndef PRIVLIB
  342. #define PRIVLIB "/usr/local/lib/perl"
  343. #endif
  344.     incpush(PRIVLIB);
  345.     (void)apush(stab_array(incstab),str_make(".",1));
  346. #endif
  347.  
  348.     str_set(&str_no,No);
  349.     str_set(&str_yes,Yes);
  350.  
  351.     /* open script */
  352.  
  353.     if (scriptname == Nullch)
  354. #ifdef MSDOS
  355.     {
  356.     if ( isatty(fileno(stdin)) )
  357.       moreswitches("v");
  358.     scriptname = "-";
  359.     }
  360. #else
  361. #ifdef macintosh
  362.     scriptname = "Dev:Stdin";
  363. #else
  364.     scriptname = "-";
  365. #endif
  366. #endif
  367. #ifdef macintosh
  368.     if (dosearch && !index(scriptname, ':') && (s = getenv("Commands"))) {
  369. #else
  370.     if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
  371. #endif
  372.     char *xfound = Nullch, *xfailed = Nullch;
  373.     int len;
  374.  
  375.     bufend = s + strlen(s);
  376.     while (*s) {
  377. #ifndef DOSISH
  378. #ifndef macintosh
  379.         s = cpytill(tokenbuf,s,bufend,':',&len);
  380. #else
  381.         for (len = 0; *s && *s != ','; tokenbuf[len++] = *s++);
  382.         tokenbuf[len] = '\0';
  383. #endif
  384. #else
  385. #ifdef atarist
  386.         for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
  387.         tokenbuf[len] = '\0';
  388. #else
  389.         for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
  390.         tokenbuf[len] = '\0';
  391. #endif
  392. #endif
  393.         if (*s)
  394.         s++;
  395. #ifndef DOSISH
  396. #ifdef macintosh
  397.         if (len && tokenbuf[len-1] != ':')
  398.         (void)strcat(tokenbuf+len,":");
  399. #else
  400.         if (len && tokenbuf[len-1] != '/')
  401.         (void)strcat(tokenbuf+len,"/");
  402. #endif
  403. #else
  404. #ifdef atarist
  405.         if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
  406.         (void)strcat(tokenbuf+len,"/");
  407. #else
  408.         if (len && tokenbuf[len-1] != '\\')
  409.         (void)strcat(tokenbuf+len,"\\");
  410. #endif
  411. #endif
  412.         (void)strcat(tokenbuf+len,scriptname);
  413. #ifdef DEBUGGING
  414. #ifdef macintosh
  415.         if (debug & 1)
  416.         fprintf(perldbg,"Looking for %s\n",tokenbuf);
  417. #else
  418.         if (debug & 1)
  419.         fprintf(stderr,"Looking for %s\n",tokenbuf);
  420. #endif
  421. #endif
  422.         if (stat(tokenbuf,&statbuf) < 0)        /* not there? */
  423.         continue;
  424.         if (S_ISREG(statbuf.st_mode)
  425.          && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
  426.         xfound = tokenbuf;              /* bingo! */
  427.         break;
  428.         }
  429.         if (!xfailed)
  430.         xfailed = savestr(tokenbuf);
  431.     }
  432.     if (!xfound)
  433.         fatal("Can't execute %s", xfailed ? xfailed : scriptname );
  434.     if (xfailed)
  435.         Safefree(xfailed);
  436.     scriptname = savestr(xfound);
  437.     }
  438.  
  439.     fdpid = anew(Nullstab);    /* for remembering popen pids by fd */
  440.     pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
  441.  
  442.     origfilename = savestr(scriptname);
  443.     curcmd->c_filestab = fstab(origfilename);
  444.     if (strEQ(origfilename,"-"))
  445.     argv[0] = "";
  446.     if (preprocess) {
  447. #ifndef macintosh
  448.     char *cpp = CPPSTDIN;
  449.  
  450.     if (strEQ(cpp,"cppstdin"))
  451.         sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
  452.     else
  453.         sprintf(tokenbuf, "%s", cpp);
  454. #endif
  455. #ifdef PRIVLIB
  456.     str_cat(str,"-I");
  457.     str_cat(str,PRIVLIB);
  458. #endif
  459. #ifdef macintosh
  460.     (void)sprintf(buf, 
  461. "StreamEdit -e '/•[¬#]/"
  462.                 "||/ç•#[ ∂t]*include[ ∂t]/"
  463.         "||/ç•#[ ∂t]*define[ ∂t]/"
  464.         "||/ç•#[ ∂t]*if[ ∂t]/"
  465.         "||/ç•#[ ∂t]*ifdef[ ∂t]/"
  466.         "||/ç•#[ ∂t]*ifndef[ ∂t]/"
  467.         "||/ç•#[ ∂t]*else/"
  468.         "||/ç•#[ ∂t]*elif/"
  469.         "||/ç•#[ ∂t]*undef/"
  470.         "||/ç•#[ ∂t]*endif/ Next' "
  471.                "-e '/ç•[ ∂t]*#≈/ Delete' "
  472. " %s | C -e %s",
  473.       scriptname, str_get(str));
  474. #else
  475. #ifdef MSDOS
  476.     (void)sprintf(buf, "\
  477. sed %s -e \"/^[^#]/b\" \
  478.  -e \"/^#[     ]*include[     ]/b\" \
  479.  -e \"/^#[     ]*define[     ]/b\" \
  480.  -e \"/^#[     ]*if[     ]/b\" \
  481.  -e \"/^#[     ]*ifdef[     ]/b\" \
  482.  -e \"/^#[     ]*ifndef[     ]/b\" \
  483.  -e \"/^#[     ]*else/b\" \
  484.  -e \"/^#[     ]*elif[     ]/b\" \
  485.  -e \"/^#[     ]*undef[     ]/b\" \
  486.  -e \"/^#[     ]*endif/b\" \
  487.  -e \"s/^#.*//\" \
  488.  %s | %s -C %s %s",
  489.       (doextract ? "-e \"1,/^#/d\n\"" : ""),
  490. #else
  491.     (void)sprintf(buf, "\
  492. %s %s -e '/^[^#]/b' \
  493.  -e '/^#[     ]*include[     ]/b' \
  494.  -e '/^#[     ]*define[     ]/b' \
  495.  -e '/^#[     ]*if[     ]/b' \
  496.  -e '/^#[     ]*ifdef[     ]/b' \
  497.  -e '/^#[     ]*ifndef[     ]/b' \
  498.  -e '/^#[     ]*else/b' \
  499.  -e '/^#[     ]*elif[     ]/b' \
  500.  -e '/^#[     ]*undef[     ]/b' \
  501.  -e '/^#[     ]*endif/b' \
  502.  -e 's/^[     ]*#.*//' \
  503.  %s | %s -C %s %s",
  504. #ifdef LOC_SED
  505.       LOC_SED,
  506. #else
  507.       "sed",
  508. #endif
  509.       (doextract ? "-e '1,/^#/d\n'" : ""),
  510. #endif
  511.       scriptname, tokenbuf, str_get(str), CPPMINUS);
  512. #endif
  513. #ifdef DEBUGGING
  514. #ifdef macintosh
  515.     if (debug & 64) {
  516.         fputs(buf,perldbg);
  517.         fputs("\n",perldbg);
  518.     }
  519. #else
  520.     if (debug & 64) {
  521.         fputs(buf,stderr);
  522.         fputs("\n",stderr);
  523.     }
  524. #endif
  525. #endif
  526.     doextract = FALSE;
  527. #ifdef IAMSUID                /* actually, this is caught earlier */
  528.     if (euid != uid && !euid) {    /* if running suidperl */
  529. #ifdef HAS_SETEUID
  530.         (void)seteuid(uid);        /* musn't stay setuid root */
  531. #else
  532. #ifdef HAS_SETREUID
  533.         (void)setreuid(-1, uid);
  534. #else
  535.         setuid(uid);
  536. #endif
  537. #endif
  538.         if (geteuid() != uid)
  539.         fatal("Can't do seteuid!\n");
  540.     }
  541. #endif /* IAMSUID */
  542.     rsfp = mypopen(buf,"r");
  543.     }
  544.     else if (!*scriptname) {
  545. #ifdef TAINT
  546.     if (euid != uid || egid != gid)
  547.         fatal("Can't take set-id script from stdin");
  548. #endif
  549.     rsfp = stdin;
  550.     }
  551.     else
  552.     rsfp = fopen(scriptname,"r");
  553.     if ((FILE*)rsfp == Nullfp) {
  554. #ifdef DOSUID
  555. #ifndef IAMSUID        /* in case script is not readable before setuid */
  556.     if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
  557.       statbuf.st_mode & (S_ISUID|S_ISGID)) {
  558.         (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  559.         execv(buf, origargv);    /* try again */
  560.         fatal("Can't do setuid\n");
  561.     }
  562. #endif
  563. #endif
  564.     fatal("Can't open perl script \"%s\": %s\n",
  565.       stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
  566.     }
  567.     str_free(str);        /* free -I directories */
  568.     str = Nullstr;
  569.  
  570.     /* do we need to emulate setuid on scripts? */
  571.  
  572.     /* This code is for those BSD systems that have setuid #! scripts disabled
  573.      * in the kernel because of a security problem.  Merely defining DOSUID
  574.      * in perl will not fix that problem, but if you have disabled setuid
  575.      * scripts in the kernel, this will attempt to emulate setuid and setgid
  576.      * on scripts that have those now-otherwise-useless bits set.  The setuid
  577.      * root version must be called suidperl or sperlN.NNN.  If regular perl
  578.      * discovers that it has opened a setuid script, it calls suidperl with
  579.      * the same argv that it had.  If suidperl finds that the script it has
  580.      * just opened is NOT setuid root, it sets the effective uid back to the
  581.      * uid.  We don't just make perl setuid root because that loses the
  582.      * effective uid we had before invoking perl, if it was different from the
  583.      * uid.
  584.      *
  585.      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
  586.      * be defined in suidperl only.  suidperl must be setuid root.  The
  587.      * Configure script will set this up for you if you want it.
  588.      *
  589.      * There is also the possibility of have a script which is running
  590.      * set-id due to a C wrapper.  We want to do the TAINT checks
  591.      * on these set-id scripts, but don't want to have the overhead of
  592.      * them in normal perl, and can't use suidperl because it will lose
  593.      * the effective uid info, so we have an additional non-setuid root
  594.      * version called taintperl or tperlN.NNN that just does the TAINT checks.
  595.      */
  596.  
  597. #ifdef DOSUID
  598.     if (fstat(fileno(rsfp),&statbuf) < 0)    /* normal stat is insecure */
  599.     fatal("Can't stat script \"%s\"",origfilename);
  600.     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
  601.     int len;
  602.  
  603. #ifdef IAMSUID
  604. #ifndef HAS_SETREUID
  605.     /* On this access check to make sure the directories are readable,
  606.      * there is actually a small window that the user could use to make
  607.      * filename point to an accessible directory.  So there is a faint
  608.      * chance that someone could execute a setuid script down in a
  609.      * non-accessible directory.  I don't know what to do about that.
  610.      * But I don't think it's too important.  The manual lies when
  611.      * it says access() is useful in setuid programs.
  612.      */
  613.     if (access(stab_val(curcmd->c_filestab)->str_ptr,1))    /*double check*/
  614.         fatal("Permission denied");
  615. #else
  616.     /* If we can swap euid and uid, then we can determine access rights
  617.      * with a simple stat of the file, and then compare device and
  618.      * inode to make sure we did stat() on the same file we opened.
  619.      * Then we just have to make sure he or she can execute it.
  620.      */
  621.     {
  622.         struct stat tmpstatbuf;
  623.  
  624.         if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
  625.         fatal("Can't swap uid and euid");    /* really paranoid */
  626.         if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
  627.         fatal("Permission denied");    /* testing full pathname here */
  628.         if (tmpstatbuf.st_dev != statbuf.st_dev ||
  629.         tmpstatbuf.st_ino != statbuf.st_ino) {
  630.         (void)fclose(rsfp);
  631.         if (rsfp = mypopen("/bin/mail root","w")) {    /* heh, heh */
  632.             fprintf(rsfp,
  633. "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
  634. (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
  635.             uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
  636.             statbuf.st_dev, statbuf.st_ino,
  637.             stab_val(curcmd->c_filestab)->str_ptr,
  638.             statbuf.st_uid, statbuf.st_gid);
  639.             (void)mypclose(rsfp);
  640.         }
  641.         fatal("Permission denied\n");
  642.         }
  643.         if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
  644.         fatal("Can't reswap uid and euid");
  645.         if (!cando(S_IXUSR,FALSE,&statbuf))        /* can real uid exec? */
  646.         fatal("Permission denied\n");
  647.     }
  648. #endif /* HAS_SETREUID */
  649. #endif /* IAMSUID */
  650.  
  651.     if (!S_ISREG(statbuf.st_mode))
  652.         fatal("Permission denied");
  653.     if (statbuf.st_mode & S_IWOTH)
  654.         fatal("Setuid/gid script is writable by world");
  655.     doswitches = FALSE;        /* -s is insecure in suid */
  656.     curcmd->c_line++;
  657.     if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
  658.       strnNE(tokenbuf,"#!",2) )    /* required even on Sys V */
  659.         fatal("No #! line");
  660.     s = tokenbuf+2;
  661.     if (*s == ' ') s++;
  662.     while (!isSPACE(*s)) s++;
  663.     if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
  664.         fatal("Not a perl script");
  665.     while (*s == ' ' || *s == '\t') s++;
  666.     /*
  667.      * #! arg must be what we saw above.  They can invoke it by
  668.      * mentioning suidperl explicitly, but they may not add any strange
  669.      * arguments beyond what #! says if they do invoke suidperl that way.
  670.      */
  671.     len = strlen(validarg);
  672.     if (strEQ(validarg," PHOOEY ") ||
  673.         strnNE(s,validarg,len) || !isSPACE(s[len]))
  674.         fatal("Args must match #! line");
  675.  
  676. #ifndef IAMSUID
  677.     if (euid != uid && (statbuf.st_mode & S_ISUID) &&
  678.         euid == statbuf.st_uid)
  679.         if (!do_undump)
  680.         fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  681. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  682. #endif /* IAMSUID */
  683.  
  684.     if (euid) {    /* oops, we're not the setuid root perl */
  685.         (void)fclose(rsfp);
  686. #ifndef IAMSUID
  687.         (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  688.         execv(buf, origargv);    /* try again */
  689. #endif
  690.         fatal("Can't do setuid\n");
  691.     }
  692.  
  693.     if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
  694. #ifdef HAS_SETEGID
  695.         (void)setegid(statbuf.st_gid);
  696. #else
  697. #ifdef HAS_SETREGID
  698.         (void)setregid((GIDTYPE)-1,statbuf.st_gid);
  699. #else
  700.         setgid(statbuf.st_gid);
  701. #endif
  702. #endif
  703.         if (getegid() != statbuf.st_gid)
  704.         fatal("Can't do setegid!\n");
  705.     }
  706.     if (statbuf.st_mode & S_ISUID) {
  707.         if (statbuf.st_uid != euid)
  708. #ifdef HAS_SETEUID
  709.         (void)seteuid(statbuf.st_uid);    /* all that for this */
  710. #else
  711. #ifdef HAS_SETREUID
  712.         (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
  713. #else
  714.         setuid(statbuf.st_uid);
  715. #endif
  716. #endif
  717.         if (geteuid() != statbuf.st_uid)
  718.         fatal("Can't do seteuid!\n");
  719.     }
  720.     else if (uid) {            /* oops, mustn't run as root */
  721. #ifdef HAS_SETEUID
  722.         (void)seteuid((UIDTYPE)uid);
  723. #else
  724. #ifdef HAS_SETREUID
  725.         (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
  726. #else
  727.         setuid((UIDTYPE)uid);
  728. #endif
  729. #endif
  730.         if (geteuid() != uid)
  731.         fatal("Can't do seteuid!\n");
  732.     }
  733.     uid = (int)getuid();
  734.     euid = (int)geteuid();
  735.     gid = (int)getgid();
  736.     egid = (int)getegid();
  737.     if (!cando(S_IXUSR,TRUE,&statbuf))
  738.         fatal("Permission denied\n");    /* they can't do this */
  739.     }
  740. #ifdef IAMSUID
  741.     else if (preprocess)
  742.     fatal("-P not allowed for setuid/setgid script\n");
  743.     else
  744.     fatal("Script is not setuid/setgid in suidperl\n");
  745. #else
  746. #ifndef TAINT        /* we aren't taintperl or suidperl */
  747.     /* script has a wrapper--can't run suidperl or we lose euid */
  748.     else if (euid != uid || egid != gid) {
  749.     (void)fclose(rsfp);
  750.     (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  751.     execv(buf, origargv);    /* try again */
  752.     fatal("Can't run setuid script with taint checks");
  753.     }
  754. #endif /* TAINT */
  755. #endif /* IAMSUID */
  756. #else /* !DOSUID */
  757. #ifndef TAINT        /* we aren't taintperl or suidperl */
  758.     if (euid != uid || egid != gid) {    /* (suidperl doesn't exist, in fact) */
  759. #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
  760.     fstat(fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
  761.     if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
  762.         ||
  763.         (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
  764.        )
  765.         if (!do_undump)
  766.         fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  767. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  768. #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
  769.     /* not set-id, must be wrapped */
  770.     (void)fclose(rsfp);
  771.     (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  772.     execv(buf, origargv);    /* try again */
  773.     fatal("Can't run setuid script with taint checks");
  774.     }
  775. #endif /* TAINT */
  776. #endif /* DOSUID */
  777.  
  778. #if !defined(IAMSUID) && !defined(TAINT)
  779.  
  780.     /* skip forward in input to the real script? */
  781.  
  782. #ifdef MAC_STANDALONE
  783.     /* Since the Mac OS does not honor !# arguments for us, we do it ourselves */
  784.     
  785.     while (1) {
  786.     if ((s = str_gets(linestr, rsfp, 0)) == Nullch) {
  787.         if (doextract) {
  788.             DialogPtr    dlg;
  789.         char         file[256];
  790.         
  791.         strcpy(file+1, MPWFileName(origfilename));
  792.         file[0] = strlen(file+1);
  793.         ParamText((StringPtr) file, "\p", "\p", "\p");
  794.         
  795.         if (Alert(270, (ModalFilterProcPtr) nil) == 2)
  796.             fatal("User aborted script\n");
  797.         else
  798.             doextract = FALSE;
  799.         }            
  800.         
  801.         /* Pater peccavi, file does not have #! */
  802.         rewind(rsfp);
  803.         
  804.         break;
  805.     }
  806.     if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
  807.         ungetc('\n',rsfp);        /* to keep line count right */
  808.         doextract = FALSE;
  809.         if (s = instr(s,"perl -")) {
  810.         s += 6;
  811. /* A truly horrible hack, but anybody who specifies -d in the #! line deserves
  812.    this
  813. */
  814.         for (;s; s = moreswitches(s)) 
  815.             if (*s == 'd' && !perldb)
  816.             (void)hadd(aadd(curcmd->c_filestab));
  817.         }
  818.         break;
  819.     }
  820.     extract_offset++;
  821.     } 
  822. #else
  823.     while (doextract) {
  824.     if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
  825.         fatal("No Perl script found in input\n");
  826.     if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
  827.         ungetc('\n',rsfp);        /* to keep line count right */
  828.         doextract = FALSE;
  829.         if (s = instr(s,"perl -")) {
  830.         s += 6;
  831.         /*SUPPRESS 530*/
  832. #ifdef macintosh
  833. /* A truly horrible hack, but anybody who specifies -d in the #! line deserves
  834.    this
  835. */
  836.         for (;s; s = moreswitches(s)) 
  837.             if (*s == 'd' && !perldb)
  838.             (void)hadd(aadd(curcmd->c_filestab));
  839. #else
  840.         while (s = moreswitches(s)) ;
  841. #endif
  842.         }
  843.         if (cddir && chdir(cddir) < 0)
  844.         fatal("Can't chdir to %s",cddir);
  845.     }
  846. #ifdef macintosh
  847.     if (doextract)
  848.         extract_offset++;
  849. #endif
  850.     }
  851. #endif
  852. #endif /* !defined(IAMSUID) && !defined(TAINT) */
  853.  
  854.     defstab = stabent("_",TRUE);
  855.  
  856.     subname = str_make("main",4);
  857.     if (perldb) {
  858.     debstash = hnew(0);
  859.     stab_xhash(stabent("_DB",TRUE)) = debstash;
  860.     curstash = debstash;
  861.     dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
  862.     tmpstab->str_pok |= SP_MULTI;
  863.     dbargs->ary_flags = 0;
  864.     DBstab = stabent("DB",TRUE);
  865.     DBstab->str_pok |= SP_MULTI;
  866.     DBline = stabent("dbline",TRUE);
  867.     DBline->str_pok |= SP_MULTI;
  868.     DBsub = hadd(tmpstab = stabent("sub",TRUE));
  869.     tmpstab->str_pok |= SP_MULTI;
  870.     DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
  871.     tmpstab->str_pok |= SP_MULTI;
  872.     DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
  873.     tmpstab->str_pok |= SP_MULTI;
  874.     DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
  875.     tmpstab->str_pok |= SP_MULTI;
  876.     curstash = defstash;
  877.     }
  878.  
  879.     /* init tokener */
  880.  
  881.     bufend = bufptr = str_get(linestr);
  882.  
  883.     savestack = anew(Nullstab);        /* for saving non-local values */
  884.     stack = anew(Nullstab);        /* for saving non-local values */
  885.     stack->ary_flags = 0;        /* not a real array */
  886.     afill(stack,63); afill(stack,-1);    /* preextend stack */
  887.     afill(savestack,63); afill(savestack,-1);
  888.  
  889.     /* now parse the script */
  890.  
  891.     error_count = 0;
  892.     if (yyparse() || error_count) {
  893.     if (minus_c)
  894. #ifdef macintosh
  895.         fatal("%s had compilation errors.\n", MPWFileName(origfilename));
  896. #else
  897.         fatal("%s had compilation errors.\n", origfilename);
  898. #endif
  899.     else {
  900.         fatal("Execution of %s aborted due to compilation errors.\n",
  901. #ifdef macintosh
  902.         MPWFileName(origfilename));
  903. #else
  904.         origfilename);
  905. #endif
  906.     }
  907.     }
  908.  
  909.     New(50,loop_stack,128,struct loop);
  910. #ifdef DEBUGGING
  911.     if (debug) {
  912.     New(51,debname,128,char);
  913.     New(52,debdelim,128,char);
  914. #ifdef macintosh
  915. #ifdef MAC_STANDALONE
  916.     perldbg = fopen(perldbgname, "w");
  917.     if (!perldbg)
  918.        perldbg = stderr;
  919. #else
  920.     perldbg = stderr;
  921. #endif
  922. #endif
  923.     }
  924. #endif
  925.     curstash = defstash;
  926.  
  927.     preprocess = FALSE;
  928.     if (e_fp) {
  929.     e_fp = Nullfp;
  930.     (void)UNLINK(e_tmpname);
  931.     }
  932.  
  933.     /* initialize everything that won't change if we undump */
  934.  
  935.     if (sigstab = stabent("SIG",allstabs)) {
  936.     sigstab->str_pok |= SP_MULTI;
  937.     (void)hadd(sigstab);
  938.     }
  939.  
  940.     magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
  941.     userinit();        /* in case linked C routines want magical variables */
  942.     macperlinit();
  943.  
  944.     amperstab = stabent("&",allstabs);
  945.     leftstab = stabent("`",allstabs);
  946.     rightstab = stabent("'",allstabs);
  947.     sawampersand = (amperstab || leftstab || rightstab);
  948.     if (tmpstab = stabent(":",allstabs))
  949.     str_set(stab_val(tmpstab),chopset);
  950.     if (tmpstab = stabent("\024",allstabs))
  951.     time(&basetime);
  952.  
  953.     /* these aren't necessarily magical */
  954.     if (tmpstab = stabent("\014",allstabs)) {
  955.     str_set(stab_val(tmpstab),"\f");
  956.     formfeed = stab_val(tmpstab);
  957.     }
  958.     if (tmpstab = stabent(";",allstabs))
  959.     str_set(STAB_STR(tmpstab),"\034");
  960.     if (tmpstab = stabent("]",allstabs)) {
  961.     str = STAB_STR(tmpstab);
  962.     str_set(str,rcsid);
  963.     str->str_u.str_nval = atof(patchlevel);
  964.     str->str_nok = 1;
  965.     }
  966.     str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
  967.  
  968.     stdinstab = stabent("STDIN",TRUE);
  969.     stdinstab->str_pok |= SP_MULTI;
  970.     if (!stab_io(stdinstab))
  971.     stab_io(stdinstab) = stio_new();
  972.     stab_io(stdinstab)->ifp = stdin;
  973.     tmpstab = stabent("stdin",TRUE);
  974.     stab_io(tmpstab) = stab_io(stdinstab);
  975.     tmpstab->str_pok |= SP_MULTI;
  976.  
  977.     tmpstab = stabent("STDOUT",TRUE);
  978.     tmpstab->str_pok |= SP_MULTI;
  979.     if (!stab_io(tmpstab))
  980.     stab_io(tmpstab) = stio_new();
  981.     stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
  982.     defoutstab = tmpstab;
  983.     tmpstab = stabent("stdout",TRUE);
  984.     stab_io(tmpstab) = stab_io(defoutstab);
  985.     tmpstab->str_pok |= SP_MULTI;
  986.  
  987.     curoutstab = stabent("STDERR",TRUE);
  988.     curoutstab->str_pok |= SP_MULTI;
  989.     if (!stab_io(curoutstab))
  990.     stab_io(curoutstab) = stio_new();
  991.     stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
  992.     tmpstab = stabent("stderr",TRUE);
  993.     stab_io(tmpstab) = stab_io(curoutstab);
  994.     tmpstab->str_pok |= SP_MULTI;
  995.     curoutstab = defoutstab;        /* switch back to STDOUT */
  996.  
  997.     statname = Str_new(66,0);        /* last filename we did stat on */
  998.  
  999.     /* now that script is parsed, we can modify record separator */
  1000.  
  1001.     rs = nrs;
  1002.     rslen = nrslen;
  1003.     rschar = nrschar;
  1004.     rspara = (nrslen == 2);
  1005.     str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
  1006.  
  1007.     if (do_undump)
  1008.     my_unexec();
  1009.  
  1010.   just_doit:        /* come here if running an undumped a.out */
  1011.     argc--,argv++;    /* skip name of script */
  1012.     if (doswitches) {
  1013.     for (; argc > 0 && **argv == '-'; argc--,argv++) {
  1014.         if (argv[0][1] == '-') {
  1015.         argc--,argv++;
  1016.         break;
  1017.         }
  1018.         if (s = index(argv[0], '=')) {
  1019.         *s++ = '\0';
  1020.         str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
  1021.         }
  1022.         else
  1023.         str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
  1024.     }
  1025.     }
  1026. #ifdef TAINT
  1027.     tainted = 1;
  1028. #endif
  1029.     if (tmpstab = stabent("0",allstabs)) {
  1030. #ifdef macintosh
  1031.     str_set(stab_val(tmpstab), MPWFileName(origfilename));
  1032. #else
  1033.     str_set(stab_val(tmpstab),origfilename);
  1034. #endif
  1035.     magicname("0", Nullch, 0);
  1036.     }
  1037.     if (tmpstab = stabent("\030",allstabs))
  1038.     str_set(stab_val(tmpstab),origargv[0]);
  1039.     if (argvstab = stabent("ARGV",allstabs)) {
  1040.     argvstab->str_pok |= SP_MULTI;
  1041.     (void)aadd(argvstab);
  1042.     aclear(stab_array(argvstab));
  1043.     for (; argc > 0; argc--,argv++) {
  1044.         (void)apush(stab_array(argvstab),str_make(argv[0],0));
  1045.     }
  1046.     }
  1047. #ifdef TAINT
  1048.     (void) stabent("ENV",TRUE);        /* must test PATH and IFS */
  1049. #endif
  1050.     if (envstab = stabent("ENV",allstabs)) {
  1051.     envstab->str_pok |= SP_MULTI;
  1052.     (void)hadd(envstab);
  1053.     hclear(stab_hash(envstab), FALSE);
  1054.     if (env != environ)
  1055.         environ[0] = Nullch;
  1056.     for (; *env; env++) {
  1057.         if (!(s = index(*env,'=')))
  1058.         continue;
  1059.         *s++ = '\0';
  1060.         str = str_make(s--,0);
  1061.         str_magic(str, envstab, 'E', *env, s - *env);
  1062.         (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
  1063.         *s = '=';
  1064.     }
  1065.     }
  1066. #ifdef TAINT
  1067.     tainted = 0;
  1068. #endif
  1069.     if (tmpstab = stabent("$",allstabs))
  1070.     str_numset(STAB_STR(tmpstab),(double)getpid());
  1071.  
  1072.     if (dowarn) {
  1073.     stab_check('A','Z');
  1074.     stab_check('a','z');
  1075.     }
  1076.  
  1077.     if (setjmp(top_env))    /* sets goto_targ on longjump */
  1078.     loop_ptr = -1;        /* start label stack again */
  1079.  
  1080. #ifdef DEBUGGING
  1081.     if (debug & 1024)
  1082.     dump_all();
  1083. #ifdef macintosh
  1084.     if (debug)
  1085.     fprintf(perldbg,"\nEXECUTING...\n\n");
  1086. #else
  1087.     if (debug)
  1088.     fprintf(stderr,"\nEXECUTING...\n\n");
  1089. #endif
  1090. #endif
  1091.  
  1092.     if (minus_c) {
  1093. #ifdef macintosh
  1094.     fprintf(stderr,"%s syntax OK\n", origfilename);
  1095. #else
  1096.     fprintf(stderr,"%s syntax OK\n", MPWFileName(origfilename));
  1097. #endif
  1098.     exit(0);
  1099.     }
  1100.  
  1101.     /* do it */
  1102.  
  1103.     (void) cmd_exec(main_root,G_SCALAR,-1);
  1104.  
  1105.     if (goto_targ)
  1106.     fatal("Can't find label \"%s\"--aborting",goto_targ);
  1107.     exit(0);
  1108.     /* NOTREACHED */
  1109. }
  1110.  
  1111. void
  1112. magicalize(list)
  1113. register char *list;
  1114. {
  1115.     char sym[2];
  1116.  
  1117.     sym[1] = '\0';
  1118.     while (*sym = *list++)
  1119.     magicname(sym, Nullch, 0);
  1120. }
  1121.  
  1122. void
  1123. magicname(sym,name,namlen)
  1124. char *sym;
  1125. char *name;
  1126. int namlen;
  1127. {
  1128.     register STAB *stab;
  1129.  
  1130.     if (stab = stabent(sym,allstabs)) {
  1131.     stab_flags(stab) = SF_VMAGIC;
  1132.     str_magic(stab_val(stab), stab, 0, name, namlen);
  1133.     }
  1134. }
  1135.  
  1136. static void
  1137. incpush(p)
  1138. char *p;
  1139. {
  1140.     char *s;
  1141.  
  1142.     if (!p)
  1143.     return;
  1144.  
  1145.     /* Break at all separators */
  1146.     while (*p) {
  1147.     /* First, skip any consecutive separators */
  1148.     while ( *p == PERLLIB_SEP ) {
  1149.         /* Uncomment the next line for PATH semantics */
  1150.         /* (void)apush(stab_array(incstab), str_make(".", 1)); */
  1151.         p++;
  1152.     }
  1153. #ifdef MAC_STANDALONE
  1154.     if (!strncmp(p, "~:", 2)) {
  1155.         char *ex;
  1156.         char  expanded[500];
  1157.         
  1158.         p += 2;
  1159.         if (s = strrchr(origargv[0], ':')) {
  1160.             strncpy(expanded, origargv[0], s-origargv[0]+1);
  1161.         ex = expanded+(s-origargv[0]+1);
  1162.         } else
  1163.             ex = expanded;
  1164.         if (s = strrchr(p+2, PERLLIB_SEP)) {
  1165.             strncpy(ex, s, s-p);
  1166.             p = s + 1;
  1167.         } else {
  1168.             strcpy(ex, p);
  1169.         p = NULL;
  1170.         }
  1171.         (void)apush(stab_array(incstab), str_make(expanded, 0));
  1172.         if (!p)
  1173.             break;
  1174.     } else
  1175. #endif
  1176.     if ( (s = index(p, PERLLIB_SEP)) != Nullch ) {
  1177.         (void)apush(stab_array(incstab), str_make(p, (int)(s - p)));
  1178.         p = s + 1;
  1179.     } else {
  1180.         (void)apush(stab_array(incstab), str_make(p, 0));
  1181.         break;
  1182.     }
  1183.     }
  1184. }
  1185.  
  1186. void
  1187. savelines(array, str)
  1188. ARRAY *array;
  1189. STR *str;
  1190. {
  1191.     register char *s = str->str_ptr;
  1192.     register char *send = str->str_ptr + str->str_cur;
  1193.     register char *t;
  1194.     register int line = 1;
  1195.  
  1196.     while (s && s < send) {
  1197.     STR *tmpstr = Str_new(85,0);
  1198.  
  1199.     t = index(s, '\n');
  1200.     if (t)
  1201.         t++;
  1202.     else
  1203.         t = send;
  1204.  
  1205.     str_nset(tmpstr, s, t - s);
  1206.     astore(array, line++, tmpstr);
  1207.     s = t;
  1208.     }
  1209. }
  1210.  
  1211. /* this routine is in perl.c by virtue of being sort of an alternate main() */
  1212.  
  1213. int
  1214. do_eval(str,optype,stash,savecmd,gimme,arglast)
  1215. STR *str;
  1216. int optype;
  1217. HASH *stash;
  1218. int savecmd;
  1219. int gimme;
  1220. int *arglast;
  1221. {
  1222.     STR **st = stack->ary_array;
  1223.     int retval;
  1224.     CMD *myroot = Nullcmd;
  1225.     ARRAY *ar;
  1226.     int i;
  1227.     CMD * VOLATILE oldcurcmd = curcmd;
  1228.     VOLATILE int oldtmps_base = tmps_base;
  1229.     VOLATILE int oldsave = savestack->ary_fill;
  1230.     VOLATILE int oldperldb = perldb;
  1231.     SPAT * VOLATILE oldspat = curspat;
  1232.     SPAT * VOLATILE oldlspat = lastspat;
  1233.     VOLATILE int sp = arglast[0];
  1234.     char *specfilename;
  1235.     char *tmpfilename;
  1236.     int parsing = 1;
  1237.     static char * last_eval = Nullch;
  1238.     static long last_elen = 0;
  1239.     static CMD * last_root = Nullcmd;
  1240.  
  1241.     tmps_base = tmps_max;
  1242.     if (curstash != stash) {
  1243. #ifndef macintosh
  1244.     (void)savehptr(&curstash);
  1245. #else
  1246.     savehptr(&curstash);
  1247. #endif
  1248.     curstash = stash;
  1249.     }
  1250.     str_set(stab_val(stabent("@",TRUE)),"");
  1251.     if (curcmd->c_line == 0)        /* don't debug debugger... */
  1252.     perldb = FALSE;
  1253.     curcmd = &compiling;
  1254.     if (optype == O_EVAL) {        /* normal eval */
  1255.     curcmd->c_filestab = fstab("(eval)");
  1256.     curcmd->c_line = 1;
  1257.     str_sset(linestr,str);
  1258.     str_cat(linestr,";\n;\n");    /* be kind to them */
  1259.     if (perldb)
  1260.         savelines(stab_xarray(curcmd->c_filestab), linestr);
  1261.     }
  1262.     else {
  1263.     if (last_root && !in_eval) {
  1264.         Safefree(last_eval);
  1265.         last_eval = Nullch;
  1266.         cmd_free(last_root);
  1267.         last_root = Nullcmd;
  1268.     }
  1269.     specfilename = str_get(str);
  1270.     str_set(linestr,"");
  1271.     if (optype == O_REQUIRE && &str_undef !=
  1272.       hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
  1273.         curcmd = oldcurcmd;
  1274.         tmps_base = oldtmps_base;
  1275.         st[++sp] = &str_yes;
  1276.         perldb = oldperldb;
  1277.         return sp;
  1278.     }
  1279.     tmpfilename = savestr(specfilename);
  1280. #ifdef macintosh
  1281.     if ((strchr(tmpfilename, ':') != NULL) && *tmpfilename != ':') {
  1282. #else
  1283.     if (*tmpfilename == '/' || 
  1284.         (*tmpfilename == '.' &&
  1285.             (tmpfilename[1] == '/' ||
  1286.          (tmpfilename[1] == '.' && tmpfilename[2] == '/'))))
  1287.     {
  1288. #endif
  1289.         rsfp = fopen(tmpfilename,"r");
  1290.     }
  1291.     else {
  1292.         ar = stab_array(incstab);
  1293.         for (i = 0; i <= ar->ary_fill; i++) {
  1294. #ifdef macintosh
  1295.         char *macptr = str_get(afetch(ar,i,TRUE));
  1296.         int   colon1 = macptr[strlen(macptr)-1] == ':';
  1297.         int   colon2 = *specfilename == ':';
  1298.         
  1299.         if (colon1 && colon2)
  1300.             (void) sprintf(buf, "%s%s", macptr, specfilename+1);
  1301.         else if (colon1 || colon2 )
  1302.             (void) sprintf(buf, "%s%s", macptr, specfilename);
  1303.         else 
  1304.             (void) sprintf(buf, "%s:%s", macptr, specfilename);
  1305. #else
  1306.         (void)sprintf(buf, "%s/%s",
  1307.           str_get(afetch(ar,i,TRUE)), specfilename);
  1308. #endif
  1309.         rsfp = fopen(buf,"r");
  1310.         if (rsfp) {
  1311.             char *s = buf;
  1312.  
  1313. #ifndef macintosh
  1314.             if (*s == '.' && s[1] == '/')
  1315.             s += 2;
  1316. #endif
  1317.             Safefree(tmpfilename);
  1318.             tmpfilename = savestr(s);
  1319.             break;
  1320.         }
  1321.         }
  1322.     }
  1323.     curcmd->c_filestab = fstab(tmpfilename);
  1324.     Safefree(tmpfilename);
  1325.     tmpfilename = Nullch;
  1326.     if (!rsfp) {
  1327.         curcmd = oldcurcmd;
  1328.         tmps_base = oldtmps_base;
  1329.         if (optype == O_REQUIRE) {
  1330.         sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
  1331.         if (instr(tokenbuf,".h "))
  1332.             strcat(tokenbuf," (change .h to .ph maybe?)");
  1333.         if (instr(tokenbuf,".ph "))
  1334.             strcat(tokenbuf," (did you run h2ph?)");
  1335.         fatal("%s",tokenbuf);
  1336.         }
  1337.         if (gimme != G_ARRAY)
  1338.         st[++sp] = &str_undef;
  1339.         perldb = oldperldb;
  1340.         return sp;
  1341.     }
  1342.     curcmd->c_line = 0;
  1343.     }
  1344.     in_eval++;
  1345.     oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
  1346.     bufend = bufptr + linestr->str_cur;
  1347.     if (++loop_ptr >= loop_max) {
  1348.     loop_max += 128;
  1349.     Renew(loop_stack, loop_max, struct loop);
  1350.     }
  1351.     loop_stack[loop_ptr].loop_label = "_EVAL_";
  1352.     loop_stack[loop_ptr].loop_sp = sp;
  1353. #ifdef DEBUGGING
  1354.     if (debug & 4) {
  1355.     deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  1356.     }
  1357. #endif
  1358.     eval_root = Nullcmd;
  1359.     if (setjmp(loop_stack[loop_ptr].loop_env)) {
  1360.     retval = 1;
  1361.     }
  1362.     else {
  1363.     error_count = 0;
  1364.     if (rsfp) {
  1365.         retval = yyparse();
  1366.         retval |= error_count;
  1367.     }
  1368.     else if (last_root && last_elen == bufend - bufptr
  1369.       && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){
  1370.         retval = 0;
  1371.         eval_root = last_root;    /* no point in reparsing */
  1372.     }
  1373.     else if (in_eval == 1 && !savecmd) {
  1374.         if (last_root) {
  1375.         Safefree(last_eval);
  1376.         last_eval = Nullch;
  1377.         cmd_free(last_root);
  1378.         }
  1379.         last_root = Nullcmd;
  1380.         last_elen = bufend - bufptr;
  1381.         last_eval = nsavestr(bufptr, last_elen);
  1382.         retval = yyparse();
  1383.         retval |= error_count;
  1384.         if (!retval)
  1385.         last_root = eval_root;
  1386.         if (!last_root) {
  1387.         Safefree(last_eval);
  1388.         last_eval = Nullch;
  1389.         }
  1390.     }
  1391.     else
  1392.         retval = yyparse();
  1393.     }
  1394.     myroot = eval_root;        /* in case cmd_exec does another eval! */
  1395.  
  1396.     if (retval || error_count) {
  1397.     st = stack->ary_array;
  1398.     sp = arglast[0];
  1399.     if (gimme != G_ARRAY)
  1400.         st[++sp] = &str_undef;
  1401.     if (parsing) {
  1402. #ifndef MANGLEDPARSE
  1403. #ifdef DEBUGGING
  1404. #ifdef macintosh
  1405.         if (debug & 128)
  1406.         fprintf(perldbg,"Freeing eval_root %lx\n",(long)eval_root);
  1407. #else
  1408.         if (debug & 128)
  1409.         fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
  1410. #endif
  1411. #endif
  1412.         cmd_free(eval_root);
  1413. #endif
  1414.         /*SUPPRESS 29*/ /*SUPPRESS 30*/
  1415.         if ((CMD*)eval_root == last_root)
  1416.         last_root = Nullcmd;
  1417.         eval_root = myroot = Nullcmd;
  1418.     }
  1419.     if (rsfp) {
  1420.         fclose(rsfp);
  1421.         rsfp = 0;
  1422.     }
  1423.     }
  1424.     else {
  1425.     parsing = 0;
  1426.     sp = cmd_exec(eval_root,gimme,sp);
  1427.     st = stack->ary_array;
  1428.     for (i = arglast[0] + 1; i <= sp; i++)
  1429.         st[i] = str_mortal(st[i]);
  1430.                 /* if we don't save result, free zaps it */
  1431.     if (savecmd)
  1432.         eval_root = myroot;
  1433.     else if (in_eval != 1 && myroot != last_root)
  1434.         cmd_free(myroot);
  1435.         if (eval_root == myroot)
  1436.         eval_root = Nullcmd;
  1437.     }
  1438.  
  1439.     perldb = oldperldb;
  1440.     in_eval--;
  1441. #ifdef DEBUGGING
  1442.     if (debug & 4) {
  1443.     char *tmps = loop_stack[loop_ptr].loop_label;
  1444.     deb("(Popping label #%d %s)\n",loop_ptr,
  1445.         tmps ? tmps : "" );
  1446.     }
  1447. #endif
  1448.     loop_ptr--;
  1449.     tmps_base = oldtmps_base;
  1450.     curspat = oldspat;
  1451.     lastspat = oldlspat;
  1452.     if (savestack->ary_fill > oldsave)    /* let them use local() */
  1453.     restorelist(oldsave);
  1454.  
  1455.     if (optype != O_EVAL) {
  1456.     if (retval) {
  1457.         if (optype == O_REQUIRE)
  1458.         fatal("%s", str_get(stab_val(stabent("@",TRUE))));
  1459.     }
  1460.     else {
  1461.         curcmd = oldcurcmd;
  1462.         if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
  1463.         (void)hstore(stab_hash(incstab), specfilename,
  1464.           strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
  1465.               0 );
  1466.         }
  1467.         else if (optype == O_REQUIRE)
  1468.         fatal("%s did not return a true value", specfilename);
  1469.     }
  1470.     }
  1471.     curcmd = oldcurcmd;
  1472.     return sp;
  1473. }
  1474.  
  1475. int
  1476. do_try(cmd,gimme,arglast)
  1477. CMD *cmd;
  1478. int gimme;
  1479. int *arglast;
  1480. {
  1481.     STR **st = stack->ary_array;
  1482.  
  1483.     CMD * VOLATILE oldcurcmd = curcmd;
  1484.     VOLATILE int oldtmps_base = tmps_base;
  1485.     VOLATILE int oldsave = savestack->ary_fill;
  1486.     SPAT * VOLATILE oldspat = curspat;
  1487.     SPAT * VOLATILE oldlspat = lastspat;
  1488.     VOLATILE int sp = arglast[0];
  1489.  
  1490.     tmps_base = tmps_max;
  1491.     str_set(stab_val(stabent("@",TRUE)),"");
  1492.     in_eval++;
  1493.     if (++loop_ptr >= loop_max) {
  1494.     loop_max += 128;
  1495.     Renew(loop_stack, loop_max, struct loop);
  1496.     }
  1497.     loop_stack[loop_ptr].loop_label = "_EVAL_";
  1498.     loop_stack[loop_ptr].loop_sp = sp;
  1499. #ifdef DEBUGGING
  1500.     if (debug & 4) {
  1501.     deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  1502.     }
  1503. #endif
  1504.     if (setjmp(loop_stack[loop_ptr].loop_env)) {
  1505.     st = stack->ary_array;
  1506.     sp = arglast[0];
  1507.     if (gimme != G_ARRAY)
  1508.         st[++sp] = &str_undef;
  1509.     }
  1510.     else {
  1511.     sp = cmd_exec(cmd,gimme,sp);
  1512.     st = stack->ary_array;
  1513. /*    for (i = arglast[0] + 1; i <= sp; i++)
  1514.         st[i] = str_mortal(st[i]);  not needed, I think */
  1515.                 /* if we don't save result, free zaps it */
  1516.     }
  1517.  
  1518.     in_eval--;
  1519. #ifdef DEBUGGING
  1520.     if (debug & 4) {
  1521.     char *tmps = loop_stack[loop_ptr].loop_label;
  1522.     deb("(Popping label #%d %s)\n",loop_ptr,
  1523.         tmps ? tmps : "" );
  1524.     }
  1525. #endif
  1526.     loop_ptr--;
  1527.     tmps_base = oldtmps_base;
  1528.     curspat = oldspat;
  1529.     lastspat = oldlspat;
  1530.     curcmd = oldcurcmd;
  1531.     if (savestack->ary_fill > oldsave)    /* let them use local() */
  1532.     restorelist(oldsave);
  1533.  
  1534.     return sp;
  1535. }
  1536.  
  1537. /* This routine handles any switches that can be given during run */
  1538.  
  1539. static char *
  1540. moreswitches(s)
  1541. char *s;
  1542. {
  1543.     int numlen;
  1544.  
  1545.     switch (*s) {
  1546.     case '0':
  1547.     nrschar = scanoct(s, 4, &numlen);
  1548.     nrs = nsavestr("\n",1);
  1549.     *nrs = nrschar;
  1550.     if (nrschar > 0377) {
  1551.         nrslen = 0;
  1552.         nrs = "";
  1553.     }
  1554.     else if (!nrschar && numlen >= 2) {
  1555.         nrslen = 2;
  1556.         nrs = "\n\n";
  1557.         nrschar = '\n';
  1558.     }
  1559.     return s + numlen;
  1560.     case 'a':
  1561.     minus_a = TRUE;
  1562.     s++;
  1563.     return s;
  1564.     case 'c':
  1565.     minus_c = TRUE;
  1566.     s++;
  1567.     return s;
  1568.     case 'd':
  1569. #ifdef TAINT
  1570.     if (euid != uid || egid != gid)
  1571.         fatal("No -d allowed in setuid scripts");
  1572. #endif
  1573.     perldb = TRUE;
  1574.     s++;
  1575.     return s;
  1576.     case 'D':
  1577. #ifdef DEBUGGING
  1578. #ifdef TAINT
  1579.     if (euid != uid || egid != gid)
  1580.         fatal("No -D allowed in setuid scripts");
  1581. #endif
  1582.     debug = atoi(s+1) | 32768;
  1583. #else
  1584.     warn("Recompile perl with -DDEBUGGING to use -D switch\n");
  1585. #endif
  1586.     /*SUPPRESS 530*/
  1587.     for (s++; isDIGIT(*s); s++) ;
  1588.     return s;
  1589.     case 'i':
  1590.     inplace = savestr(s+1);
  1591.     /*SUPPRESS 530*/
  1592.     for (s = inplace; *s && !isSPACE(*s); s++) ;
  1593.     *s = '\0';
  1594.     break;
  1595.     case 'I':
  1596. #ifdef TAINT
  1597.     if (euid != uid || egid != gid)
  1598.         fatal("No -I allowed in setuid scripts");
  1599. #endif
  1600.     if (*++s) {
  1601.         (void)apush(stab_array(incstab),str_make(s,0));
  1602.     }
  1603.     else
  1604.         fatal("No space allowed after -I");
  1605.     break;
  1606.     case 'l':
  1607.     minus_l = TRUE;
  1608.     s++;
  1609.     if (isDIGIT(*s)) {
  1610.         ors = savestr("\n");
  1611.         orslen = 1;
  1612.         *ors = scanoct(s, 3 + (*s == '0'), &numlen);
  1613.         s += numlen;
  1614.     }
  1615.     else {
  1616.         ors = nsavestr(nrs,nrslen);
  1617.         orslen = nrslen;
  1618.     }
  1619.     return s;
  1620.     case 'n':
  1621.     minus_n = TRUE;
  1622.     s++;
  1623.     return s;
  1624.     case 'p':
  1625.     minus_p = TRUE;
  1626.     s++;
  1627.     return s;
  1628.     case 'u':
  1629.     do_undump = TRUE;
  1630.     s++;
  1631.     return s;
  1632.     case 'U':
  1633.     unsafe = TRUE;
  1634.     s++;
  1635.     return s;
  1636.     case 'v':
  1637.     fputs("\nThis is perl, version 4.0\n\n",stdout);
  1638.     fputs(rcsid,stdout);
  1639.     fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
  1640. #ifdef macintosh
  1641.     fputs("MPW port Copyright (c) 1991-93 Matthias Neeracher & Tim Endres\n",
  1642.     stdout);
  1643. #endif    
  1644. #ifdef MSDOS
  1645.     fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
  1646.     stdout);
  1647. #ifdef OS2
  1648.         fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
  1649.         stdout);
  1650. #endif
  1651. #endif
  1652. #ifdef atarist
  1653.         fputs("atariST series port, ++jrb  bammi@cadence.com\n", stdout);
  1654. #endif
  1655.     fputs("\n\
  1656. Perl may be copied only under the terms of the Perl Artistic License \n\
  1657. which may be found in the Perl 4.0 source kit.\n",stdout);
  1658. #ifdef MSDOS
  1659.         usage(origargv[0]);
  1660. #endif
  1661.     exit(0);
  1662.     case 'w':
  1663.     dowarn = TRUE;
  1664.     s++;
  1665.     return s;
  1666.     case ' ':
  1667.     case '\n':
  1668.     case '\t':
  1669.     break;
  1670.     default:
  1671. #ifdef macintosh
  1672.         if (doextract)
  1673. #endif
  1674.         fatal("Switch meaningless after -x: -%s",s);
  1675.     }
  1676.     return Nullch;
  1677. }
  1678.  
  1679. /* compliments of Tom Christiansen */
  1680.  
  1681. /* unexec() can be found in the Gnu emacs distribution */
  1682.  
  1683. void
  1684. my_unexec()
  1685. {
  1686. #ifdef UNEXEC
  1687.     int    status;
  1688.     extern int etext;
  1689.     static char dumpname[BUFSIZ];
  1690.     static char perlpath[256];
  1691.  
  1692.     sprintf (dumpname, "%s.perldump", origfilename);
  1693.     sprintf (perlpath, "%s/perl", BIN);
  1694.  
  1695.     status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
  1696.     if (status)
  1697.     fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
  1698.     exit(status);
  1699. #else
  1700. #ifdef DOSISH
  1701.     abort();    /* nothing else to do */
  1702. #else /* ! MSDOS */
  1703. #   ifndef SIGABRT
  1704. #    define SIGABRT SIGILL
  1705. #   endif
  1706. #   ifndef SIGILL
  1707. #    define SIGILL 6        /* blech */
  1708. #   endif
  1709.     kill(getpid(),SIGABRT);    /* for use with undump */
  1710. #endif /* ! MSDOS */
  1711. #endif
  1712. }
  1713.  
  1714.